home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 041-050 / amok42 / ewkal / ewkal.mod < prev    next >
Text File  |  1993-11-04  |  10KB  |  213 lines
  1. (*********************************************************************
  2.  *
  3.  *  :Program.           Gibt für jedes Datum den Wochentag aus
  4.  *  :Author.            Hans Schafft
  5.  *  :Address.           Landfriedstraße 1A - Hinterhaus
  6.  *  :Address.           6900 Heidelberg
  7.  *  :Phone.             06221 - 22416
  8.  *  :Version.           1.0
  9.  *  :Date.              13.7.1990
  10.  *  :Copyright.         PD
  11.  *  :Language.          Oberon
  12.  *  :Translator.        Amiga Oberon Compiler 1.0, Demo Version
  13.  *
  14.  *********************************************************************)
  15.  
  16. MODULE ewKAL;
  17.  
  18. IMPORT d : Dos,s : SYSTEM, e : Exec, i : Intuition,g : Graphics;
  19.  
  20. CONST YPos1 = 20; YPos2 = 28; YPos3 = 36; YPos4 = 54; XPos1 = 20;
  21.  XPos2 = 45; XPos3 = 70; XPos4 = 142;
  22.  tzp = 0;tep = 1; mzp = 2; mep = 3; jtp = 4; jhp = 5; jzp = 6; jep = 7;
  23.  tzm = 8;tem = 9;mzm = 10;mem = 11;jtm = 12;jhm = 13;jzm = 14;jem = 15;
  24.  
  25. VAR monat,tag,jahr,len,p,wt,oberGrenze : INTEGER;
  26. wiPtr : i.WindowPtr; scPtr : i.ScreenPtr; Datum : d.Date;rpPtr: g.RastPortPtr;
  27. Gad : ARRAY 16 OF i.Gadget;moar : ARRAY 13,10 OF CHAR;tagName: ARRAY 7,10 OF CHAR;
  28. wota : ARRAY 7,26 OF CHAR;
  29.  
  30. PROCEDURE FensterAuf(VAR wiPtr : i.WindowPtr);
  31. VAR  w :  i.NewWindow; iPtr : i.IntuitionBasePtr;
  32. BEGIN
  33.   w.leftEdge  := 100;    w.topEdge  := 50;
  34.   w.width  := 237;    w.height  := 110;
  35.   w.detailPen  := 2;     w.blockPen := 1;
  36.   w.title  := s.ADR(" ewKAL © H.Schafft ");
  37.   w.flags  := LONGSET{i.windowDepth,i.windowDrag,i.rmbTrap,i.activate,i.reportMouse,i.windowClose};
  38.   w.idcmpFlags  := LONGSET{i.gadgetUp,i.mouseButtons,i.gadgetDown,i.closeWindow};
  39.   w.type  := {i.wbenchScreen};
  40.   w.screen  := NIL;  w.minWidth := 240;
  41.   w.minHeight  := 100;   w.maxWidth := 240;
  42.   w.firstGadget := NIL;   w.bitMap   := NIL;
  43.   w.checkMark  := NIL;   w.maxHeight:= 100;
  44.   wiPtr := i.OpenWindow(w);
  45. END FensterAuf;
  46.  
  47. PROCEDURE WochenTag(t,m,j : INTEGER);
  48. VAR h,r,kh,kr,k : INTEGER;
  49. BEGIN
  50.   IF m <= 2 THEN IF m = 2 THEN t := t + 31; END; m := 13;j := j - 1;  END;
  51.   h := j DIV 100;  r := j MOD 100;  kh := h MOD 4;  kr := r MOD 4;
  52.   IF m < 8 THEN    k := 3;  ELSE    k := 7;  END;
  53.   IF (m MOD 2) = 0 THEN    k := 5;  END;
  54.   wt := ((2000 * kh + 10 * (r - kr) + kr) + 1000 * m + 100 * k + t) MOD 7;
  55. END WochenTag;
  56.  
  57. PROCEDURE ReadDiscDate;(* von Pit Burkhatdt auf AMOK#1 - leicht gekürzt *)
  58.   VAR n : LONGINT;
  59.   BEGIN  d.DateStamp(s.ADR(Datum)); (* Datum von Startdisc lesen *)
  60.   n:=Datum.days-2251;  jahr:=SHORT((4*n+3) DIV 1461);  n:=n-1461*jahr DIV 4;
  61.   jahr:=jahr+84;  monat:=SHORT((5*n+2) DIV 153);  tag:=SHORT(n-(153*monat+2) DIV 5+1);
  62.   monat:=monat+3;  IF (monat>12) THEN jahr:=jahr+1; monat:=monat-12; END; (*IF*)
  63.   jahr := jahr + 1900;
  64. END ReadDiscDate;
  65.  
  66. PROCEDURE Auswerten(stelle : INTEGER);
  67. BEGIN  CASE stelle OF
  68.   | tzp : INC(tag,10); IF tag > oberGrenze THEN DEC(tag,10);END;
  69.   | tep : INC(tag); IF tag > oberGrenze THEN tag := 1;END;
  70.   | mzp : INC(monat,10);IF monat > 12 THEN DEC(monat,10);END;
  71.   | mep : INC(monat); IF monat > 12 THEN monat := 1;END;
  72.   | jtp : INC(jahr,1000);IF jahr > 9999 THEN DEC(jahr,10000);END;
  73.   | jhp : INC(jahr,100);IF jahr > 9999 THEN DEC(jahr,1000);END;
  74.   | jzp : INC(jahr,10);IF jahr > 9999 THEN DEC(jahr,100);END;
  75.   | jep : INC(jahr);IF jahr > 9999 THEN DEC(jahr);END;
  76.   | tzm : DEC(tag,10);IF tag = 0 THEN tag := oberGrenze;
  77.                       ELSIF tag < 0 THEN INC(tag,10); END;
  78.   | tem : DEC(tag);IF tag = 0 THEN  tag := oberGrenze;END;
  79.   | mzm : DEC(monat,10);IF monat <= 0 THEN INC(monat,10);END;
  80.   | mem : DEC(monat);IF monat <= 0 THEN monat := 12;END;
  81.   | jtm : DEC(jahr,1000);IF jahr < 0 THEN INC(jahr,10000); END;
  82.   | jhm : DEC(jahr,100);IF jahr < 0  THEN INC(jahr,1000);END;
  83.   | jzm : DEC(jahr,10);IF jahr < 0  THEN INC(jahr,100); END;
  84.   | jem : DEC(jahr);IF jahr < 0  THEN INC(jahr,10);END;
  85.   ELSE  END;
  86. END Auswerten;
  87.  
  88. PROCEDURE IDCMPAbfrage() : BOOLEAN;
  89. VAR gadPtr : i.GadgetPtr;
  90.     msgPtr : i.IntuiMessagePtr;
  91.     class  : LONGSET;
  92.     id     : INTEGER;
  93. BEGIN
  94.   e.WaitPort(wiPtr^.userPort);
  95.   REPEAT
  96.     msgPtr := e.GetMsg(wiPtr^.userPort);
  97.   UNTIL msgPtr # NIL ;
  98.   class := msgPtr^.class; gadPtr := msgPtr^.iAddress;
  99.   id := gadPtr^.gadgetID; e.ReplyMsg(msgPtr);
  100.   IF i.gadgetUp IN class THEN Auswerten(id); ELSE END;
  101.   IF i.closeWindow IN class THEN RETURN FALSE; ELSE RETURN TRUE; END;
  102. END IDCMPAbfrage;
  103.  
  104. PROCEDURE PfeileUndTage;
  105. VAR ar : ARRAY 2 OF CHAR;
  106. BEGIN
  107.   wota[0] := "SA  SO  MO  DI  MI  DO  FR";  wota[1] := "SO  MO  DI  MI  DO  FR  SA";
  108.   wota[2] := "MO  DI  MI  DO  FR  SA  SO";  wota[3] := "DI  MI  DO  FR  SA  SO  MO";
  109.   wota[4] := "MI  DO  FR  SA  SO  MO  DI";  wota[5] := "DO  FR  SA  SO  MO  DI  MI";
  110.   wota[6] := "FR  SA  SO  MO  DI  MI  DO";
  111.   moar[1] := "   Januar ";  moar[2] := "  Februar ";  moar[3] := "     März ";
  112.   moar[4] := "    April ";  moar[5] := "      Mai ";  moar[6] := "     Juni ";
  113.   moar[7] := "     Juli ";  moar[8] := "   August ";  moar[9] := "September ";
  114.   moar[10] := "  Oktober ";  moar[11] := " November ";  moar[12] := " Dezember ";
  115.   tagName[0] := "Samstag   ";  tagName[1] := "Sonntag   ";  tagName[2] := "Montag    ";
  116.   tagName[3] := "Dienstag  ";  tagName[4] := "Mittwoch  ";  tagName[5] := "Donnerstag";
  117.   tagName[6] := "Freitag   ";   g.SetDrMd(rpPtr,g.jam1);   ar := "^^";
  118.   g.SetAPen(rpPtr,3);  g.Move(rpPtr,XPos1,YPos1-1);  g.Text(rpPtr, s.ADR(ar),2);
  119.   g.Move(rpPtr,XPos2,YPos1-1);  g.Text(rpPtr, s.ADR(ar),2);  g.Move(rpPtr,XPos3,YPos1-1);  g.Text(rpPtr, s.ADR(ar),2);
  120.   g.Text(rpPtr, s.ADR(ar),2);   ar := "vv";
  121.   g.Move(rpPtr,XPos1,YPos3+1);  g.Text(rpPtr, s.ADR(ar),2);
  122.   g.Move(rpPtr,XPos2,YPos3+1);  g.Text(rpPtr, s.ADR(ar),2);
  123.   g.Move(rpPtr,XPos3,YPos3+1);  g.Text(rpPtr, s.ADR(ar),2);  g.Text(rpPtr, s.ADR(ar),2);
  124.   g.Move(rpPtr,XPos1-7,YPos4 + 10);  g.Text(rpPtr,s.ADR(" 1   2   3   4   5   6   7"),26);
  125.   g.Move(rpPtr,XPos1-7,YPos4 + 20);  g.Text(rpPtr,s.ADR(" 8   9  10  11  12  13  14"),26);
  126.   g.Move(rpPtr,XPos1-7,YPos4 + 30);  g.Text(rpPtr,s.ADR("15  16  17  18  19  20  21"),26);
  127.   g.Move(rpPtr,XPos1-7,YPos4 + 40);  g.Text(rpPtr,s.ADR("22  23  24  25  26  27  28"),26);   ar := "^^";
  128.   g.SetAPen(rpPtr,2);g.Move(rpPtr,XPos1,YPos1); g.Text(rpPtr, s.ADR(ar),2);
  129.   g.Move(rpPtr,XPos2,YPos1);  g.Text(rpPtr, s.ADR(ar),2);
  130.   g.Move(rpPtr,XPos3,YPos1);  g.Text(rpPtr, s.ADR(ar),2);
  131.   g.Text(rpPtr, s.ADR(ar),2);   ar := "vv";
  132.   g.Move(rpPtr,XPos1,YPos3);  g.Text(rpPtr, s.ADR(ar),2);
  133.   g.Move(rpPtr,XPos2,YPos3);  g.Text(rpPtr, s.ADR(ar),2);
  134.   g.Move(rpPtr,XPos3,YPos3);  g.Text(rpPtr, s.ADR(ar),2);
  135.   g.Text(rpPtr, s.ADR(ar),2);   g.SetDrMd(rpPtr,g.jam2);  g.SetBPen(rpPtr,0);
  136. END PfeileUndTage;
  137.  
  138. PROCEDURE Ausgabe;
  139. VAR tar,mar : ARRAY 2 OF CHAR;jar : ARRAY 4 OF CHAR;y,x : INTEGER;err : BOOLEAN;
  140. BEGIN  WochenTag(tag,monat,jahr);
  141.   tar[0] := CHR(tag DIV 10 + 48); IF tag < 10 THEN tar[0] := " ";END;
  142.   tar[1] := CHR(tag MOD 10 + 48);
  143.   mar[0] := CHR(monat DIV 10 + 48); IF monat < 10 THEN mar[0] := " ";END;
  144.   mar[1] := CHR(monat MOD 10 + 48);
  145.   IF jahr < 1000 THEN jar[0] := " ";
  146.   ELSE jar[0] := CHR(jahr DIV 1000 + 48);
  147.   END;
  148.   x := jahr MOD 1000;
  149.   IF jahr < 100 THEN jar[1] := " ";
  150.   ELSE  jar[1] := CHR(x DIV 100 + 48);
  151.   END;
  152.   x := x MOD 100;
  153.   IF jahr < 10 THEN jar[2] := " ";
  154.   ELSE jar[2] := CHR(x DIV 10 + 48);
  155.   END;
  156.   jar[3] := CHR(x MOD 10 + 48);
  157.   g.SetAPen(rpPtr,3);  g.Move(rpPtr,XPos1,YPos2);  g.Text(rpPtr, s.ADR(tar),2);
  158.   g.Move(rpPtr,XPos2,YPos2);  g.Text(rpPtr, s.ADR(mar),2);
  159.   g.Move(rpPtr,XPos3,YPos2);  g.Text(rpPtr, s.ADR(jar),4);   g.SetAPen(rpPtr,1);
  160.   g.Move(rpPtr,XPos4,YPos2);  g.Text(rpPtr, s.ADR(tagName[wt]),10);
  161.   WochenTag(1,monat,jahr); (* Die Wochentag - Leiste aktualisieren *)
  162.   g.Move(rpPtr,XPos1-8,YPos4-1);  g.Text(rpPtr,s.ADR(wota[wt]),26);
  163.   g.Move(rpPtr,XPos4-33,YPos4 + 50); (* Monat und Jahr rechts unten *)
  164.   g.Text(rpPtr,s.ADR(moar[monat]),10);  g.Text(rpPtr, s.ADR(jar),4);
  165.   IF monat = 12 THEN WochenTag(1,1,jahr+1);ELSE WochenTag(1,monat+1,jahr); END;
  166.   x := wt;   y := 28;
  167.   REPEAT    INC(y);    WochenTag(y,monat,jahr);  UNTIL x = wt;
  168.   g.SetAPen(rpPtr,3);  g.Move(rpPtr,XPos1-7,YPos4 + 50);
  169.   CASE y OF
  170.   | 29 : g.Text(rpPtr,s.ADR("          "),10);  | 30 : g.Text(rpPtr,s.ADR("29        "),10);
  171.   | 31 : g.Text(rpPtr,s.ADR("29  30    "),10);  | 32 : g.Text(rpPtr,s.ADR("29  30  31"),10);
  172.   ELSE  END;  oberGrenze := y - 1;
  173. END Ausgabe;
  174.  
  175. PROCEDURE InitGadget(le,te,wi,he,id : INTEGER);
  176. VAR stelle : INTEGER;
  177. BEGIN
  178.   Gad[id].leftEdge   :=  le;  Gad[id].topEdge   :=  te;
  179.   Gad[id].width   :=  wi;  Gad[id].height  :=  he;
  180.   Gad[id].flags   :=  i.gadgHNone;
  181.   Gad[id].activation :=  {i.gadgImmediate,i.relVerify};
  182.   Gad[id].gadgetType :=  i.boolGadget;  Gad[id].gadgetRender:=  NIL;
  183.   Gad[id].gadgetText  :=  NIL;  Gad[id].mutualExclude := LONGSET{};
  184.   Gad[id].nextGadget  :=  NIL;  Gad[id].selectRender:=  NIL;
  185.   Gad[id].specialInfo :=  NIL;  Gad[id].userData    :=  NIL;
  186.   Gad[id].gadgetID    :=  id;  stelle := i.AddGadget(wiPtr,s.ADR(Gad[id]),-1);
  187.   i.RefreshGadgets(s.ADR(Gad[id]),wiPtr,NIL);
  188. END InitGadget;
  189.  
  190. PROCEDURE GadgetsEinrichten;
  191. BEGIN
  192.   InitGadget(XPos1,YPos1-9,10,10,0);  InitGadget(XPos1+8,YPos1-9,10,10,1);
  193.   InitGadget(XPos2,YPos1-9,10,10,2);  InitGadget(XPos2+8,YPos1-9,10,10,3);
  194.   InitGadget(XPos3,YPos1-9,10,10,4);  InitGadget(XPos3+8,YPos1-9,10,10,5);
  195.   InitGadget(XPos3+16,YPos1-9,10,10,6); InitGadget(XPos3+24,YPos1-9,10,10,7);
  196.   InitGadget(XPos1,YPos3-7,10,10,8);    InitGadget(XPos1+8,YPos3-7,10,10,9);
  197.   InitGadget(XPos2,YPos3-7,10,10,10);   InitGadget(XPos2+8,YPos3-7,10,10,11);
  198.   InitGadget(XPos3,YPos3-7,10,10,12);   InitGadget(XPos3+8,YPos3-7,10,10,13);
  199.   InitGadget(XPos3+16,YPos3-7,10,10,14);InitGadget(XPos3+24,YPos3-7,10,10,15);
  200. END GadgetsEinrichten;
  201.  
  202. (*****************************************************************************)
  203. BEGIN
  204.   FensterAuf(wiPtr);rpPtr := wiPtr^.rPort;GadgetsEinrichten;ReadDiscDate;
  205.   PfeileUndTage;Ausgabe;
  206.   WHILE IDCMPAbfrage() DO
  207.     Ausgabe;
  208.     IF tag > oberGrenze THEN tag := oberGrenze; Ausgabe; END;
  209.   END;
  210. CLOSE
  211.   IF wiPtr # NIL THEN i.CloseWindow(wiPtr); END;
  212. END ewKAL.
  213.